#light

module CGraph.SchemaProc

open System.Xml.Schema
open System.Xml
open CGraph.Generic
open CGraph.Generic.Algorithms
open System.Collections.Generic
open CGraph.DirectedGraph.Impl
open CGraph.DirectedGraph
open System
open System.IO
open CGraph.CGXml

(*====================================================================
Graph datatypes
======================================================================*)


type SchemaDerivationEdge(graph:IDirectedGraph,incoming:IVertex,outgoing:IVertex) =
    inherit Edge(graph,incoming,outgoing)
    
type SchemaListDerivationEdge(graph:IDirectedGraph,incoming:IVertex,outgoing:IVertex) =
    inherit SchemaDerivationEdge(graph,incoming,outgoing)
    
type SchemaSubstitutionGroupEdge(graph:IDirectedGraph,incoming:IVertex,outgoing:IVertex) =
    inherit Edge(graph,incoming,outgoing)
   
type SchemaElementEdge(graph:IDirectedGraph,incoming:IVertex,outgoing:IVertex,m_name:string) =
    inherit Edge(graph,incoming,outgoing)
    member this.Name with get = m_name
    interface INamedObject with
        member this.Name with get() = m_name
    
type SchemaAttributeEdge(graph:IDirectedGraph,incoming:IVertex,outgoing:IVertex,m_name:string) =
    inherit Edge(graph,incoming,outgoing)
    member this.Name with get = m_name
    interface INamedObject with
        member this.Name with get() = m_name
    
type SchemaUnionEdge(graph:IDirectedGraph,incoming:IVertex,outgoing:IVertex) =
    inherit Edge(graph,incoming,outgoing)
    
type SchemaAnyEdge(graph:IDirectedGraph,incoming:IVertex,outgoing:IVertex) =
    inherit Edge(graph,incoming,outgoing)

type SchemaDatatypeVertex(graph:IDirectedGraph,m_type:XmlSchemaType option,m_name:string) =
    inherit Vertex(graph) as base
    member this.Name 
        with get = m_name
    
    member this.SchemaType with get = m_type
    interface INamedObject with
        member this.Name with get() = m_name
        
        
type SchemaSubgraphDatatypeVertex(graph:IDirectedGraph,m_type:XmlSchemaType option,m_name:string, m_vertex:SchemaDatatypeVertex) =
    inherit SchemaDatatypeVertex(graph,m_type,m_name) as base
    
    member this.Vertex with get() = m_vertex
    interface INamedObject with
        member this.Name with get() = m_name
    
type SchemaAnyVertex(graph:IDirectedGraph,m_type:XmlSchemaAny) =
    inherit Vertex(graph) as base
    
    member this.SchemaType with get = m_type
    
    interface INamedObject with
        member this.Name with get() = "##any"

/// This graph is a simplification of the schema.  It contains no choice, sequence, or various
/// other elements and merely contains information about the connections between elements.
/// It remembers a quick reverse-lookup path to edges so that given any element or attribute,
/// you can quickly find edges that must relate to that element or attribute by name
/// This simplification is not completely correct, but it will do for the collada schema.
/// Known shortcomings include not handling datatypes in choice or sequence elements if they
/// are different datatypes but have the same name.
/// Also, the system is not built to take advantage of imported schemas.  If you wanted to make
/// this general to xml schema language in particular, you would need many more test cases,
/// both complex schemas and example data that conforms to that schema.
///
/// The point of this graph is not to perform validation of a document; that is already done
/// well.  The point is to provide datatype lookup systems so you can perform queries like
/// "return all xml nodes of datatype 'x'.
/// This could perhaps have been done by compiling the schema document and building lookup mechanisms
/// on the schema DOM that microsoft provided.  I also want a system that is easily specialized outside
/// the context of schema so that it can support the extension mechanisms of collada in a reasonable
/// fasion.  I believe this necessitated the graph system.  In any case, it provides an abstraction
/// layer so that you can provide functionality that is not easily supported directly in schema.
type SchemaDatatypeGraph() =
    inherit DirectedGraph()
    
    member this.CreateDatatypeVertex stype name =
        let newVert = (new SchemaDatatypeVertex(this,stype,name))
        this.AddVertex(newVert :> IVertex)
        newVert
        
    member this.CreateSubgraphDatatypeVertex stype name vert =
        let newVert = (new SchemaSubgraphDatatypeVertex(this,stype,name,vert))
        this.AddVertex (newVert :> IVertex)
        newVert
    
    member this.SchemaDerivationEdge (v1:SchemaDatatypeVertex) (v2:SchemaDatatypeVertex) =
        if v1 = v2 then raise (InvalidOperationException("Unable to derive vertex from itself" ))
        let newEdge = (new SchemaDerivationEdge(this,v1,v2))
        this.AddEdge newEdge
        newEdge
        
    member this.SchemaListDerivationEdge (v1:SchemaDatatypeVertex) (v2:SchemaDatatypeVertex) =
        if v1 = v2 then raise (InvalidOperationException("Unable to derive vertex from itself" ))
        let newEdge = (new SchemaListDerivationEdge(this,v1,v2))
        this.AddEdge newEdge
        newEdge
        
    member this.SchemaSubstitutionGroupEdge (v1:SchemaDatatypeVertex) (v2:SchemaDatatypeVertex) =
        let newEdge = new SchemaSubstitutionGroupEdge(this,v1,v2)
        this.AddEdge newEdge
        newEdge
       
    member this.CreateSchemaUnionEdge (v1:SchemaDatatypeVertex) (v2:SchemaDatatypeVertex) =
        let newEdge = new SchemaUnionEdge(this,v1,v2)
        this.AddEdge newEdge
        newEdge
        
    member this.CreateAny (v1:SchemaDatatypeVertex) (any:XmlSchemaAny) =
        let newVert = new SchemaAnyVertex(this,any)
        this.AddVertex( newVert :> IVertex )
        let newEdge = new SchemaAnyEdge( this, v1, newVert )
        this.AddEdge newEdge
        newEdge
        
    member this.GetOrCreateSchemaElementEdge (v1:SchemaDatatypeVertex) (v2:SchemaDatatypeVertex) name =
        let existing = v1.InternalOutgoing 
                        |> Seq.first (fun( edge ) ->
                            if (edge :? SchemaElementEdge) &&
                                (edge.OutgoingVertex = (v2 :> IVertex)) &&
                                 ((edge :?> SchemaElementEdge).Name = name )
                                 then
                                    Some edge
                                 else 
                                    None )
        match existing with
            | Some edge -> edge :?> SchemaElementEdge
            | None -> 
                let newEdge = new SchemaElementEdge(this,v1,v2,name)
                this.AddEdge newEdge
                newEdge
    
    member this.GetOrCreateSchemaAttributeEdge (v1:SchemaDatatypeVertex) (v2:SchemaDatatypeVertex) name =
        //Need to avoid duplicate edges.
        let existing = v1.InternalOutgoing 
                        |> Seq.first (fun( edge ) ->
                            if (edge :? SchemaAttributeEdge) &&
                                (edge.OutgoingVertex = (v2 :> IVertex)) &&
                                 ((edge :?> SchemaAttributeEdge).Name = name )
                                 then
                                    Some edge
                                 else 
                                    None )
        match existing with
            | Some edge -> edge :?> SchemaAttributeEdge
            | None -> 
                let newEdge = new SchemaAttributeEdge(this,v1,v2,name)
                this.AddEdge newEdge
                newEdge
                
(*====================================================================
Graph algorithms
======================================================================*)
                
/// Algorithm works like this:
/// Find the set of datatypes that have the name
/// at the beginning of the list.  Build lookup machines
/// that can return the current datatype they are looking at
/// or none.  At the end of the path, you can look at the returned
/// values.  If there are only one, that is your answer.  If there
/// are multiple, the query was ambiguous (error).
let FindDatatypes (vertexes:IVertex seq) path =
    let split = String.split ['/'] path
    match split with
        | first::rest ->
            let initialDtypes 
                = vertexes
                |> Seq.filter( fun( vert ) -> 
                                if (vert :? SchemaDatatypeVertex) 
                                    then 
                                        if (vert :?> SchemaDatatypeVertex).Name = first
                                            then true
                                            else false
                                    else false )
                |> Seq.map( fun( vert ) -> vert :?> SchemaDatatypeVertex )
            let mutable machines = []
            for vert in initialDtypes do
                let state = ref (Some vert) //machine state local to each machine and updated each iteration
                let machine nextStr =
                    let nextVert (edge:IEdge) = 
                        if (edge :? SchemaAttributeEdge ) || (edge :? SchemaElementEdge )
                            then 
                                let edgeName = (edge :?> INamedObject).Name
                                if edgeName = nextStr || ((edge.OutgoingVertex :?> SchemaDatatypeVertex).Name = nextStr )
                                        then 
                                            Some (edge.OutgoingVertex :?> SchemaDatatypeVertex)
                                        else
                                            None
                        else
                            None
                    let first = (!state).Value.InternalOutgoing |> Seq.first nextVert
                    state := first
                    !state
                machines <- List.Cons( (vert,machine), machines )
            for str in rest do
                let mutable next = []
                for dtype,machine in machines do
                    let result = machine str
                    match result with
                        | Some vertex -> next <- (vertex,machine)::next
                        | None -> ()
                machines <- next
            machines |> Seq.map( fun( vert,machine ) -> vert )
        | [] -> (new List<SchemaDatatypeVertex>() :> IEnumerable<SchemaDatatypeVertex>)

                
/// Return a sequence of this vertex and all of the parent vertexes  
/// This will use lazy evaluation by default, and as such is perfect
/// for most algorithms as they will mainly not make it past the first
/// vertex.     
let rec GetCurrentVertexAndParents (vertex:SchemaDatatypeVertex) =
    seq {
        yield vertex
        let derived = 
            vertex.InternalIncoming
            |> Seq.filter( fun (edge)->edge :? SchemaDerivationEdge )
            
        for edge in derived do
            yield! GetCurrentVertexAndParents (edge.IncomingVertex :?> SchemaDatatypeVertex )
    }
    
    
/// Return a master list of all incoming edges of this vertex and its
/// parent class vertexes
let GetIncomingOfVertexAndParents (vertex:SchemaDatatypeVertex) =
    GetCurrentVertexAndParents vertex
        |> Seq.map( fun(vert) -> vert.InternalIncoming )
        |> Seq.concat
       
       
/// Return a master list of all outgoing edges of this vertex and its
/// parent class vertexes
let GetOutgoingOfVertexAndParents (vertex:SchemaDatatypeVertex) =
    GetCurrentVertexAndParents vertex
        |> Seq.map( fun(vert) -> vert.InternalOutgoing )
        |> Seq.concat
        
let IsListDerived vertex =
    let list = 
        GetIncomingOfVertexAndParents vertex
        |> Seq.first (fun (edge) -> 
            if (edge :? SchemaListDerivationEdge)
                then Some edge
                else None )
    match list with
        | Some edge -> true
        | None -> false
           
                
/// Build a minimal graph out of the datatypes found from these
/// paths.  This is used to build smaller graphs for just finding
/// certain types of vertexes.  A good example is that when a collada
/// xml file is first loaded, the system needs to know globally which
/// ids,urls, and url-refs are in the file.
let BuildMinimalGraph (vertexes,paths) =
    let mutable dtypes = []
    let convertDict = Dictionary<SchemaDatatypeVertex,SchemaDatatypeVertex>()
    let retval = new SchemaDatatypeGraph()
    for path in paths do
        dtypes <- (FindDatatypes vertexes path)::dtypes
    let dtypes = dtypes |> Seq.concat
    let IsTargetDType vert =
        let vertAndBase = GetCurrentVertexAndParents vert
        ///Is this vertex or one of its parents
        ///one of the target vertexes 
        vertAndBase
        |> Seq.first (
            fun(vert) -> 
                dtypes 
                |> Seq.first( 
                    fun( dtypeVert ) -> 
                        if vert = dtypeVert 
                            then Some dtypeVert 
                            else None ) )
        
    let rec GetOrCreateVertex vert =
        let success,dest = convertDict.TryGetValue vert
        if (not success) 
            then
                let baseVert = IsTargetDType vert                    
                let dest = 
                    match baseVert with
                        | Some baseVert -> 
                            (retval.CreateSubgraphDatatypeVertex vert.SchemaType vert.Name baseVert) :> SchemaDatatypeVertex
                        | None -> retval.CreateDatatypeVertex vert.SchemaType vert.Name
                convertDict.Add( vert, dest)
                let edgeFilter (edge:IEdge) = (not (edge :? SchemaAnyEdge))
                for edge in vert.InternalIncoming |> Seq.filter edgeFilter do
                    let inc = GetOrCreateVertex (edge.IncomingVertex :?> SchemaDatatypeVertex)
                    match edge with
                        | :? SchemaElementEdge as edge -> retval.GetOrCreateSchemaElementEdge inc dest edge.Name |> ignore
                        | :? SchemaAttributeEdge as edge -> retval.GetOrCreateSchemaAttributeEdge inc dest edge.Name |> ignore
                        | :? SchemaListDerivationEdge as edge -> retval.SchemaListDerivationEdge inc dest |> ignore
                        | :? SchemaDerivationEdge as edge -> retval.SchemaDerivationEdge inc dest |> ignore
                        | :? SchemaSubstitutionGroupEdge as edge -> retval.SchemaSubstitutionGroupEdge inc dest |> ignore
                        | :? SchemaUnionEdge as edge -> retval.CreateSchemaUnionEdge inc dest |> ignore
                        | _ -> raise( System.InvalidOperationException("Failed to handle edge" ) );
                vert.InternalOutgoing
                    |> Seq.filter( fun( edge) -> edge :? SchemaDerivationEdge )
                    |> Seq.iter( fun( edge ) -> GetOrCreateVertex (edge.OutgoingVertex :?> SchemaDatatypeVertex ) |> ignore )
                dest
            else 
                dest
        
    let IsValidVertex (vert:IVertex) = 
        if (vert :? SchemaDatatypeVertex)
            then
                let vert = vert :?> SchemaDatatypeVertex
                let target = IsTargetDType vert
                match target with
                    | Some target -> GetOrCreateVertex vert |> ignore
                    | None -> ()
    vertexes |> Seq.iter IsValidVertex
    retval
    
/// Check edges for substitution groups, as well as the direct
/// property name.  Should someone use a substitution group, then
/// the it will appear as edges leading from each subgroup item to
/// base abstract item.  In effect, they point the reverse direction
/// as the derivation edges.
let EdgeMatches (edge:IEdge) name =
    if (edge :? SchemaElementEdge )
        then 
            if (edge :?> INamedObject).Name = name 
                then Some( edge.OutgoingVertex :?> SchemaDatatypeVertex )
                else //Check substitution groups
                    let out = edge.OutgoingVertex
                    out.OutgoingEdges
                    |> Seq.filter( fun (edge ) -> edge :? SchemaSubstitutionGroupEdge )
                    |> Seq.first( fun (edge ) ->
                                            let incVert = edge.OutgoingVertex :?> SchemaDatatypeVertex
                                            if incVert.Name = name
                                                then Some incVert
                                                else None )
        else
            None
        
type CGDatatypeInfo =
    | Element of ElementHandle
    //namespace,name,value
    | Attribute of string*string*string
    

let rec CGXmlDocumentDatatypes (vertex:SchemaDatatypeVertex) path node (dg:DocumentGroup) (success:(CGDatatypeInfo*IVertex->unit)) (fail:(CGDatatypeInfo->unit)) =
    for ns,name,value in dg.GetAttributes node do
        let dtype = 
            GetOutgoingOfVertexAndParents vertex
            |> Seq.first( fun (edge) -> 
                            if (edge :? SchemaAttributeEdge ) && (edge :?> INamedObject).Name = name 
                                then Some edge.OutgoingVertex
                                else None )
        match dtype with
            | Some data -> success(Attribute(ns,name,value),data)
            | None -> fail(Attribute(ns,name,value))
    let elemChildren = dg.GetChildren node
    let findMatchingEdge child edge =
        let ns,name = dg.GetElemName child
        let matches = EdgeMatches edge name
        match matches with
            | Some vert -> 
                let vertex = vert :> IVertex
                success(Element(child), vertex)
                CGXmlDocumentDatatypes vert path child dg success fail //main body recursive call
                Some vertex
            | None ->
                match edge with
                    | :? SchemaAnyEdge as anyEdge ->
                        success(Element(child),edge.OutgoingVertex)
                        Some (edge.OutgoingVertex)
                    | _ -> None
    for child in elemChildren do
        GetOutgoingOfVertexAndParents vertex
            |> Seq.first (findMatchingEdge child) |> ignore
    
    
let rec XmlDocumentDatatypes (vertex:SchemaDatatypeVertex) (node:XmlElement) (success:(XmlNode*IVertex->unit)) (fail:(XmlNode->unit)) =
    for att in node.Attributes do
        let name = att.Name
        let dtype = 
            GetOutgoingOfVertexAndParents vertex
            |> Seq.first( fun (edge) -> 
                            if (edge :? SchemaAttributeEdge ) && (edge :?> INamedObject).Name = name 
                                then Some edge.OutgoingVertex
                                else None )
        match dtype with
            | Some data -> success(att,data)
            | None -> fail(att)
            
    let elemChildren = XmlNodeChildren (node :> XmlNode)
        
    let findMatchingEdge child edge =
        let nodeChild = child :> XmlNode
        let name  = child.Name
        let matches = EdgeMatches edge name
        match matches with
            | Some vert -> 
                let vertex = vert :> IVertex
                success(nodeChild, vertex)
                XmlDocumentDatatypes vert child success fail //main body recursive call
                Some vertex
            | None ->
                match edge with
                    | :? SchemaAnyEdge as anyEdge ->
                        success(nodeChild,edge.OutgoingVertex)
                        Some (edge.OutgoingVertex)
                    | _ -> None
            
    for child in elemChildren do
        GetOutgoingOfVertexAndParents vertex
            |> Seq.first (findMatchingEdge child) |> ignore
            
type CGTypedSuccess = CGDatatypeInfo*SchemaDatatypeVertex*SchemaDatatypeVertex->unit

/// This method is meant to be used after you have created a subgraph consisting of types
/// you are interested in checking out.
/// When a subgraph is created from a list of target types, the new vertexes are annotated 
/// with extra information in the form of which target type the vertex is related to.
/// This method walks an xml document, and calls back for each of the nodes it finds
/// that relate to a target type.  The success callback's arguments are:
///     node     : XmlNode that got targeted
///     subvert  : The actual datatype of that node.
///     basevert : The target type that the datatype is derived from.
let CGXmlDocumentFilteredDatatypes vertex path node dg (success:CGTypedSuccess) =
    let fail = fun(node:CGDatatypeInfo) -> ()
    let success = 
        fun( node:CGDatatypeInfo,vert:IVertex ) ->
            if (vert :? SchemaSubgraphDatatypeVertex )
                then 
                    let subvert = vert :?> SchemaSubgraphDatatypeVertex
                    let baseVert = subvert.Vertex
                    success (node,(subvert :> SchemaDatatypeVertex),baseVert)
    CGXmlDocumentDatatypes vertex path node dg success fail

   
type TypedSuccess = XmlNode*SchemaDatatypeVertex*SchemaDatatypeVertex->unit
       
/// This method is meant to be used after you have created a subgraph consisting of types
/// you are interested in checking out.
/// When a subgraph is created from a list of target types, the new vertexes are annotated 
/// with extra information in the form of which target type the vertex is related to.
/// This method walks an xml document, and calls back for each of the nodes it finds
/// that relate to a target type.  The success callback's arguments are:
///     node     : XmlNode that got targeted
///     subvert  : The actual datatype of that node.
///     basevert : The target type that the datatype is derived from.
let XmlDocumentFilteredDatatypes vertex node (success:TypedSuccess) =
    let fail = fun(node:XmlNode) -> ()
    let success = 
        fun( node:XmlNode,vert:IVertex ) ->
            if (vert :? SchemaSubgraphDatatypeVertex )
                then 
                    let subvert = vert :?> SchemaSubgraphDatatypeVertex
                    let baseVert = subvert.Vertex
                    success (node,(subvert :> SchemaDatatypeVertex),baseVert)
    XmlDocumentDatatypes vertex node success fail
                            
        
(*====================================================================
Graph construction
======================================================================*)
            
type BuilderContext = Dictionary<string,SchemaDatatypeVertex>
    
let CreateSimple (graph:SchemaDatatypeGraph) (context:BuilderContext) name =
    let retval = graph.CreateDatatypeVertex None name 
    context.Add( name, retval )
    retval
    
let CreateSimpleTypes graph context parent children =
    for name in children do
        let newVert = CreateSimple graph context name
        graph.SchemaDerivationEdge parent newVert |> ignore

let CreateSimpleTypeStr graph context name children =
    let matcher (success,vertex) = 
        match success with
            | true -> CreateSimpleTypes graph context vertex children
            | false -> raise (new System.InvalidOperationException("Missing datatype"))
    matcher (context.TryGetValue name)
        
        
let CreateSimpleList graph context name child =
    let matcher (success,parent) = 
        match success with
            | true -> 
                let vertex = CreateSimple graph context child
                graph.SchemaListDerivationEdge parent vertex |> ignore
            | false -> raise (new System.InvalidOperationException("Missing datatype"))
    matcher (context.TryGetValue name)
                
/// Build the basic simple types.
/// http://www.w3.org/TR/xmlschema-2/#built-in-datatypes
let BuildBasicTypes (graph:SchemaDatatypeGraph) (context:BuilderContext) =
      
    let CreateSimpleTypes = CreateSimpleTypes graph context    
    let CreateSimple = CreateSimple graph context
    let CreateSimpleTypeStr = CreateSimpleTypeStr graph context
    let CreateSimpleList = CreateSimpleList graph context
    
    let anyType = CreateSimple "anyType"
    let anySimpleType = CreateSimple "anySimpleType"
    
    graph.SchemaDerivationEdge anyType anySimpleType |> ignore
    
    CreateSimpleTypes 
        anySimpleType
        [| "duration"; "dateTime"; "time"; "date"; "gYearMonth"
           ; "gYear"; "gMonth"; "gDay"; "gMonthDay"; "string"
           ; "boolean"; "base64Binary"; "hexBinary"; "float"
           ; "double"; "decimal"; "anyURI"; "QName"; "NOTATION" |]
          
    CreateSimpleTypeStr "string" [|"normalizedString" |]
    CreateSimpleTypeStr "normalizedString" [| "token" |]
    CreateSimpleTypeStr "token" [| "language"; "Name"; "NMTOKEN" |]
    CreateSimpleTypeStr "Name" [| "NCName" |]
    CreateSimpleTypeStr "NCName" [| "ID"; "IDREF"; "ENTITY" |]
    CreateSimpleTypeStr "decimal" [| "integer" |]
    CreateSimpleTypeStr "integer" [| "nonPositiveInteger"; "long"; "nonNegativeInteger" |]
    CreateSimpleTypeStr "nonPositiveInteger" [| "negativeInteger" |]
    CreateSimpleTypeStr "long" [| "int" |]
    CreateSimpleTypeStr "nonNegativeInteger" [| "unsignedLong"; "positiveInteger" |]
    CreateSimpleTypeStr "int" [| "short" |]
    CreateSimpleTypeStr "short" [| "byte" |]
    CreateSimpleTypeStr "unsignedLong" [| "unsignedInt" |]
    CreateSimpleTypeStr "unsignedInt" [| "unsignedShort" |]
    CreateSimpleTypeStr "unsignedShort" [| "unsignedByte" |]
    
    CreateSimpleList "NMTOKEN" "NMTOKENS" 
    CreateSimpleList "IDREF" "IDREFS" 
    CreateSimpleList "ENTITY" "ENTITIES"
    
let ObjsToTyped (objs:XmlSchemaObjectCollection) =
    Seq.map_to_typed (fun( (item:obj) ) -> item :?> XmlSchemaObject ) objs
  
type PPList = (unit -> unit) List

let PostProcessGeneralDerive (graph:SchemaDatatypeGraph) (context:BuilderContext) (postProcess:PPList) 
        vert baseName (edgeCreator:SchemaDatatypeVertex->unit) =
    let success,baseVert = context.TryGetValue baseName
    if success 
        then edgeCreator baseVert
        else
            postProcess.Add( fun() ->
                                let success,baseVert = context.TryGetValue baseName
                                if success then edgeCreator baseVert )

let PostProcessDerive (graph:SchemaDatatypeGraph) (context:BuilderContext) (postProcess:PPList) vert baseName =
    let derv baseVert = (graph.SchemaDerivationEdge baseVert vert) |> ignore
    PostProcessGeneralDerive graph context postProcess vert baseName derv
    
let PostProcessListDerive (graph:SchemaDatatypeGraph) (context:BuilderContext) (postProcess:PPList) vert baseName =
    let derv baseVert = (graph.SchemaListDerivationEdge baseVert vert) |> ignore
    PostProcessGeneralDerive graph context postProcess vert baseName derv
                        
let PostProcessAddAttribute (graph:SchemaDatatypeGraph) (context:BuilderContext) (postProcess:PPList) vert refName attName =
    postProcess.Add( fun() ->
        let success,target = context.TryGetValue refName
        if success then graph.GetOrCreateSchemaAttributeEdge vert target attName |> ignore )
    
    
let rec ProcessSimpleType (simple:XmlSchemaSimpleType) name (graph:SchemaDatatypeGraph) (context:BuilderContext) (postProcess:PPList) =
    let retval = graph.CreateDatatypeVertex (Some (simple :> XmlSchemaType)) name
    match simple.Content with
        | :? XmlSchemaSimpleTypeUnion as union -> 
            postProcess.Add( fun() ->
                                for smtype in union.MemberTypes do
                                    let typeName = smtype.Name
                                    let simple = context.[typeName]
                                    graph.CreateSchemaUnionEdge retval simple |> ignore )
        | :? XmlSchemaSimpleTypeList as slist -> 
            let baseName = slist.ItemTypeName.Name;
            PostProcessListDerive graph context postProcess retval baseName
                                  
        | :? XmlSchemaSimpleTypeRestriction as restriction -> 
            let restrictionName = restriction.BaseTypeName.Name;
            //Add a post process to lookup the item type
            PostProcessDerive graph context postProcess retval restrictionName
       | _ -> raise (new System.InvalidOperationException( "Unhandled simple type" ))
    retval
    
and ProcessLocalAttributes vert (graph:SchemaDatatypeGraph) (context:BuilderContext) (postProcess:PPList) atts =
    for elem in (ObjsToTyped atts) do
        match elem with
            | :? XmlSchemaAttribute as att ->
                if att.RefName <> null && att.RefName.Name.Length > 0 
                    then 
                        let refName = att.RefName.Name
                        PostProcessAddAttribute graph context postProcess vert refName att.Name
                elif att.SchemaTypeName = null || att.SchemaTypeName.Name.Length = 0
                    then //Local definition
                        let simple = att.SchemaType
                        let dtypeVtx = ProcessSimpleType simple att.Name graph context postProcess
                        graph.GetOrCreateSchemaAttributeEdge vert dtypeVtx att.Name |> ignore
                    else
                        PostProcessAddAttribute graph context postProcess vert att.SchemaTypeName.Name att.Name
            | _ -> raise (new InvalidOperationException "Object in attribute list not an attribute"  )
            
and ProcessComplexParticle (particle:obj) vert graph (context:BuilderContext) postProcess =
    let items = 
        match particle with
            | :? XmlSchemaSequence as seq -> 
                Some seq.Items
            | :? XmlSchemaChoice as choice -> 
                Some choice.Items
            | :? XmlSchemaElement as elem -> 
                ProcessElem elem graph context (Some vert) postProcess |> ignore
                None 
            | :? XmlSchemaGroupRef as gref ->
                postProcess.Add( (fun()->
                    let groupVert = context.[gref.RefName.Name]
                    let outgoingProps 
                        = groupVert.InternalOutgoing
                        |> Seq.filter (fun(edge) -> edge :? SchemaElementEdge)
                        |> Seq.map (fun(edge) -> edge :?> SchemaElementEdge)
                    for elemEdge in outgoingProps do
                        let target = elemEdge.InternalOutgoing :?> SchemaDatatypeVertex
                        graph.GetOrCreateSchemaElementEdge vert target elemEdge.Name |> ignore
                     ))
                None
            | :? XmlSchemaAny as any -> 
                graph.CreateAny vert any |> ignore
                None
            | _ -> raise (new InvalidOperationException (sprintf "Unrecognized particle type %s" (particle.GetType()).Name ))
    match items with
        | Some items -> 
            for item in items do
                ProcessComplexParticle (box item) vert graph context postProcess
        | None -> ()
    
/// Something with a content model is basically derived from something else.
and ProcessComplexElemContentModel content vert graph context postProcess =
    let baseName,atts,particle =
        match box content with
            | :? XmlSchemaSimpleContent as simple -> 
                match simple.Content with
                    | :? XmlSchemaSimpleContentExtension as extension ->
                        extension.BaseTypeName.Name,extension.Attributes,None
                    | :? XmlSchemaSimpleContentRestriction as restriction ->
                        restriction.BaseTypeName.Name,restriction.Attributes,None
                    | _ -> raise (new System.InvalidOperationException "Odd simple content model")
            | :? XmlSchemaComplexContent as complex -> 
                match complex.Content with
                    | :? XmlSchemaComplexContentExtension as extension ->
                        extension.BaseTypeName.Name,extension.Attributes,(Some extension.Particle)
                    | :? XmlSchemaComplexContentRestriction as restriction ->
                        restriction.BaseTypeName.Name,restriction.Attributes,(Some restriction.Particle)
                    | _ -> raise (new System.InvalidOperationException "Odd complex content model")
            | _ -> raise (new System.InvalidOperationException( "Unknown content model" ))
    
    ProcessLocalAttributes vert graph context postProcess atts
    match particle with
        | Some part -> 
            if part <> null then ProcessComplexParticle (box part) vert graph context postProcess
        | None -> ()
    
    PostProcessDerive graph context postProcess vert baseName
            
and ProcessComplex (complex:XmlSchemaComplexType) name (graph:SchemaDatatypeGraph) context postProcess =
    //Complex and simple always indicate a new datatype
    let newType = graph.CreateDatatypeVertex (Some (complex :> XmlSchemaType)) name
    if complex.ContentModel <> null 
        then 
            ProcessComplexElemContentModel complex.ContentModel newType graph context postProcess
        else
            ProcessLocalAttributes newType graph context postProcess complex.Attributes
            if complex.Particle <> null then ProcessComplexParticle (box complex.Particle) newType graph context postProcess
    newType
    
and ProcessElem (elem:XmlSchemaElement) (graph:SchemaDatatypeGraph) (context:BuilderContext) parent (postProcess:(unit->unit) List) = 
    let retval = 
        if elem.RefName <> null && elem.RefName.Name.Length <> 0
            then //Add a post process hook to patch up the reference
                postProcess.Add( fun() ->
                                    let vertex = context.[ elem.RefName.Name ]
                                    let edgeName = if elem.Name = null || elem.Name.Length = 0
                                                    then vertex.Name
                                                    else elem.Name
                                    match parent with
                                        | Some parent -> 
                                            graph.GetOrCreateSchemaElementEdge parent vertex edgeName |> ignore
                                        | None -> () )
                None
            else
                let retval = 
                    match elem.SchemaType with
                        | :? XmlSchemaComplexType as complex ->
                            let newType = ProcessComplex complex elem.Name graph context postProcess
                            Some newType
                        | :? XmlSchemaSimpleType as simple -> 
                            let newType = ProcessSimpleType simple elem.Name graph context postProcess
                            Some newType
                        | null -> 
                            // null when the type name tells you the info.
                            let baseName = elem.SchemaTypeName.Name
                            let name = elem.Name
                            let newType = graph.CreateDatatypeVertex None name
                            match parent with
                                | Some parent ->
                                    graph.GetOrCreateSchemaElementEdge parent newType name |> ignore
                                | None -> () //These can be defined at the top level of the schema
                            PostProcessDerive graph context postProcess newType baseName
                            Some newType
                        | _ -> raise (new System.InvalidOperationException( "Failed to figure out schema type" ) )
                match retval with
                    | Some vertex ->
                        match parent with
                            | Some parent -> 
                                graph.GetOrCreateSchemaElementEdge parent vertex elem.Name |> ignore
                            | None -> ()
                        if elem.SubstitutionGroup <> null && elem.SubstitutionGroup.Name.Length > 0
                            then
                                postProcess.Add( fun() ->
                                                    let success,subvert = context.TryGetValue elem.SubstitutionGroup.Name
                                                    if success then graph.SchemaSubstitutionGroupEdge subvert vertex |> ignore )
                    | None -> ()
                retval
    retval
    
    
                
let BuildSchemaGraph ((schema:XmlSchema),(sourcePath:string)) =
    let retval = new SchemaDatatypeGraph()
    let context = new BuilderContext()
    let postProcess = new PPList();
    //Build the base schema types.
    BuildBasicTypes retval context
    let ProcessSchemaItems (schema:XmlSchema) = 
        for item in schema.Items do
            match item with
                | :? XmlSchemaElement as elem -> 
                    let elem = ProcessElem elem retval context null postProcess
                    match elem with
                        | Some vertex -> context.Add( vertex.Name, vertex )
                        | None -> ()
                    
                | :? XmlSchemaSimpleType as elem -> 
                    let vert = ProcessSimpleType elem elem.Name retval context postProcess
                    context.[vert.Name] <- vert
                | :? XmlSchemaComplexType as elem -> 
                    let vert = ProcessComplex elem elem.Name retval context postProcess
                    context.Add( vert.Name, vert )
                | :? XmlSchemaGroup as elem -> 
                    let vert = retval.CreateDatatypeVertex None elem.Name
                    ProcessComplexParticle (box elem.Particle) vert retval context postProcess
                    context.Add( vert.Name, vert )
                | :? XmlSchemaAnnotation as elem -> ()
                | _ -> printf "unrecognized\n"
                
    for incSchema in schema.Includes do
        match incSchema with
            | :? XmlSchemaInclude as realInc ->
                let filePath = Path.GetFullPath( Path.Combine( Path.GetDirectoryName( sourcePath ), realInc.SchemaLocation ) )
                let newSchema = XmlSchema.Read(new FileStream(filePath, FileMode.Open, FileAccess.Read), null);
                ProcessSchemaItems (newSchema)
            | _ -> ()
      
    ProcessSchemaItems( schema )
    
    for proc in postProcess do proc()
    retval